C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C       I S T S T   -   Program Structurer
C
C       Malcolm Cohen
C       Numerical Algorithms Group, Ltd.
C       Central Office, Oxford.
C       March-July 1986
C
 
        PROGRAM ISTST
 
        LOGICAL TRACE
        PARAMETER (TRACE=.FALSE.)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER IODTRE,IODSYM,IODCMI,IODCMT,IODOUT,IODPLO,DESCI,DESCO,
     +          PUPTR,PUNUM,I
        INTEGER TREPTH(81),SYMPTH(81),OUTPTH(81),
     +          CMIPTH(81),CMTPTH(81),PLOPTH(81),
     +          NOOPTS(2),DUMMY(2),SYMBOL(8),TEXT(134)
 
        INTEGER OPEN,GETARG,CREATE,ZTKPTI,ZTKGTI,EQUAL,ZYINCI,ZYROOT,
     +          ZYDOWN,ZYNEXT,ZYGPUS
        EXTERNAL OPEN,ERROR,ZINIT,ZQUIT,ZYINSY,ZYINPT,REMARK,GETARG,
     +           CREATE,ZTKPTI,ZTKGTI,ZYINCI,PLOPTF,EQUAL,ZYROOT,
     +           ZYDOWN,ZYNEXT,ZYGPUS,ZCHOUT,ZYGTSY,ZYGTST,PUTLIN,
     +           ZMESS,ZUSCAN,ZFCAPU
 
        DATA NOOPTS/45,129/,DUMMY(1)/129/
 
        CALL ZINIT
 
        PLOPTH(2)=129
        IF (GETARG(1,TREPTH,81).EQ.-100) CALL STARGS(1,TREPTH)
        IF (GETARG(2,SYMPTH,81).EQ.-100) CALL STARGS(2,SYMPTH)
        IF (GETARG(3,CMIPTH,81).EQ.-100) CALL STARGS(3,CMIPTH)
        IF (GETARG(4,CMTPTH,81).EQ.-100) CALL STARGS(4,CMTPTH)
        IF (GETARG(5,OUTPTH,81).EQ.-100) CALL STARGS(5,OUTPTH)
        IF (GETARG(6,PLOPTH,81).EQ.-100) CALL STARGS(6,PLOPTH)
 
        IODTRE=OPEN(TREPTH,0)
        IF (IODTRE.EQ.-1) CALL ERROR('Can''t open parse tree')
        IODSYM=OPEN(SYMPTH,0)
        IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol table')
        IODCMI=OPEN(CMIPTH,0)
        IF (IODCMI.EQ.-1) CALL ERROR('Can''t open comment index')
        IODCMT=OPEN(CMTPTH,0)
        IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment stream')
        IODOUT=CREATE(OUTPTH,1)
        IF (IODOUT.EQ.-1) CALL ERROR('Can''t create output file')
        DESCI=ZTKGTI(2,0,0)
        DESCO=ZTKPTI(0,IODOUT,DESCI)
        IF (PLOPTH(1).NE.129 .AND. EQUAL(PLOPTH,NOOPTS).EQ.-3) THEN
            IODPLO=OPEN(PLOPTH,0)
            IF (IODPLO.EQ.-1) CALL ERROR('Can''t open option file')
            CALL PLOPTF(IODPLO)
        END IF
 
        DO 100 I=7,10
            IF (GETARG(I,TEXT,134).NE.-100) CALL POLOPT(TEXT)
 100    CONTINUE
 
        CALL ZYINPT(IODTRE)
        CALL ZYINSY(IODSYM)
        IF (ZYINCI(IODCMI).NE.-2)
     +      CALL ERROR('Couldn''t 0 comment index')
 
        PUPTR=ZYDOWN(ZYROOT())
        PUNUM=1
 200    CALL ZFCAPU(PUPTR)
        IF (TRACE) THEN
            CALL ZCHOUT('[Processing ',2)
            CALL ZYGTSY(ZYGPUS(PUNUM),SYMBOL)
            CALL ZYGTST(SYMBOL(2),TEXT)
            CALL PUTLIN(TEXT,2)
            CALL ZMESS(']',2)
        END IF
        CALL PROCPU(PUPTR,IODCMT,DESCO,TRACE)
        PUPTR=ZYNEXT(PUPTR)
        PUNUM=PUNUM+1
        IF (PUPTR.NE.0) GOTO 200
        CALL ZUSCAN(TZEOF,0,DUMMY,DESCO)
 
        CALL REMARK('[ISTST Normal Termination]')
        CALL ZQUIT(-2)
 
        END
C ----------------------------------------------------------------------
C
C       S T A R G S   -   Fetch ST command argument from standard input
C
 
        SUBROUTINE STARGS(NUMBER,PATH)
        INTEGER NUMBER,PATH(81)
 
        INTEGER ZGTCMD
        EXTERNAL ZGTCMD,ZPRMPT
 
        INTEGER I,PROMPT(25,6)
 
        SAVE PROMPT
 
C "Input parse tree: "
C "Input symbol table: "
C "Input comment index: "
C "Input comment stream: "
C "Output structured code: "
C "POLISH option file: "
 
        DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
     +97,114,115,101,32,116,114,101,101,58,32,129/,
     +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
     +121,109,98,111,108,32,116,97,98,108,101,58,
     +32,129/,
     +       (PROMPT(I,3),I=1,22)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,105,110,100,101,120,
     +58,32,129/
     +       (PROMPT(I,4),I=1,23)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,115,116,114,101,97,
     +109,58,32,129/
     +       (PROMPT(I,5),I=1,25)/79,117,116,112,117,116,32,
     +115,116,114,117,99,116,117,114,101,100,32,99,
     +111,100,101,58,32,129/,
     +       (PROMPT(I,6),I=1,21)/80,79,76,73,83,72,32,
     +111,112,116,105,111,110,32,102,105,108,101,58,
     +32,129/
 
        CALL ZPRMPT(PROMPT(1,NUMBER))
        I=ZGTCMD(PATH,0)
 
        END
C ----------------------------------------------------------------------
C
C       P R O C P U   -   Process a canonicalised program-unit
C
 
        SUBROUTINE PROCPU(PUROOT,IODCMT,DESCO,TRACE)
        INTEGER PUROOT,IODCMT,DESCO
        LOGICAL TRACE,FGOK
 
        INTEGER MFGNOD,MAXCAS
        PARAMETER (MFGNOD=1000,MAXCAS=450)
 
        INTEGER FG(8,MFGNOD),FGSIZE,CASETB(MAXCAS),NCASES,
     +          SYMBOL(8),TEXT(134),STARTN
 
        LOGICAL ZFGRAF
        INTEGER ZYNTYP,ZYPUSY
        EXTERNAL ZYNTYP,ZYPUSY,ZYGTSY,ZYGTST,REMARK,PUTLIN,ZCHOUT,ZMESS,
     +           ZPTINT,ZFGRAF
 
        FGSIZE=0
        NCASES=0
        IF (ZYNTYP(PUROOT).EQ.5) THEN
            CALL FLATTN(PUROOT,IODCMT,DESCO)
        ELSE
            FGOK=ZFGRAF(PUROOT,FG,MFGNOD,FGSIZE,CASETB,MAXCAS,NCASES,
     +                  STARTN,2)
        ENDIF
        IF (FGOK) THEN
            IF (TRACE) THEN
                CALL ZCHOUT('[Trace: Flow graph size = ',2)
                CALL ZPTINT(FGSIZE,1,2)
                CALL ZCHOUT('/',2)
                CALL ZPTINT(MFGNOD,1,2)
                CALL ZMESS(']',2)
                CALL ZCHOUT('[Trace: Case table usage = ',2)
                CALL ZPTINT(NCASES,1,2)
                CALL ZCHOUT('/',2)
                CALL ZPTINT(MAXCAS,1,2)
                CALL ZMESS(']',2)
            END IF
            CALL STRUCT(PUROOT,FG,FGSIZE,CASETB,MAXCAS,STARTN,IODCMT,
     +                  DESCO,TRACE)
        ELSE
            CALL ZCHOUT('*** Program-unit ',2)
            CALL ZYGTSY(ZYPUSY(PUROOT),SYMBOL)
            CALL ZYGTST(SYMBOL(2),TEXT)
            CALL PUTLIN(TEXT,2)
            CALL ZMESS(' n'//'ot structured',2)
            CALL FLATTN(PUROOT,IODCMT,DESCO)
        END IF
 
CDC Following code is for debugging use only.
CD        PRINT *,'Start node is ',STARTN
CD        PRINT 9000,(J,(FG(I,J),I=1,size_fg_node),J=1,FGSIZE)
CD        IF (NCASES.GT.0) THEN
CD            PRINT *,'Case Table'
CD            PRINT 9010,(I,CASETB(I),I=1,NCASES)
CD        END IF
CD9000    FORMAT(('Node',I4,': ',size_fg_node(I5)))
CD9010    FORMAT((I4,': ',I5))
CD
        END
C ----------------------------------------------------------------------
C
C       S T R U C T   -   Structure a program-unit
C
 
        SUBROUTINE STRUCT(PUROOT,FG,FGSIZE,CASETB,MAXCAS,STARTN,IODCMT,
     +                    DESCO,TRACE)
 
        INTEGER NONEXE,SLC,EXIT,BRANCH,CASE,JUMP,JOIN
        PARAMETER (NONEXE=0,SLC=1,EXIT=2,BRANCH=3,CASE=4,JUMP=5,JOIN=6)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER PUROOT,FGSIZE,MAXCAS,STARTN,IODCMT,DESCO
        LOGICAL TRACE
        INTEGER FG(8,FGSIZE),CASETB(MAXCAS)
 
        INTEGER STKSIZ
        PARAMETER (STKSIZ=100)
 
        INTEGER PTR,LNUM,I,STACK(3,STKSIZ),SP,CURN,TMP,LOOPL,ENDKD(4),
     +          ERRKD(4),TEXT(134),CONTRL,MAXSP
 
C STACK(1,*)=flowgraph node number being processed at that level
C STACK(2,*)=processing stage (for computed goto) at that level
C STACK(3,*)=value of local variable "LOOPL" (used in loop processing)
C stack pointer SP
C
C LOOPL=loop label; +ve=>repeat-loop (end with GOTO 'LOOPL'),
C                   -ve=>DO-loop (end with '-LOOPL' CONTINUE).
C
C LNUM=last label number generated (user-specified labels are deleted)
 
        INTEGER STSLC,STRPT,STDO,STIF,STXRPT,STIF2,STIF3,NEXTND
 
        INTEGER ZYNEXT,ZYDOWN,ZYNTYP,EQUAL
        EXTERNAL ZYNEXT,ZYDOWN,ZYNTYP,EQUAL,ERROR,YSTMT,ZCHOUT,ZPTINT,
     +           ZMESS
 
        DATA ENDKD/69,78,68,129/,ERRKD/69,82,82,129/
 
        LNUM=0
        MAXSP=0
C
C First, output declaratives, relabel FORMATs, and delabel others.
C
        CALL ODRFDO(PUROOT,IODCMT,DESCO)
C
C And this is where the program really starts
C
        CURN=STARTN
        SP=0
        CONTRL=1
C
C Control Section: loop through here for iteration, sequencing and
C                  recursion control.
C
 100    GOTO (200,300,400,500,1000,600,1500) CONTRL
        CALL ERROR('GETFORM: INTERNAL CALLING SEQUENCE ERROR')
C
C Enter "GETFORM": Perform node-dependent tasks
C
 200    IF (FG(1,CURN).GT.0 .AND. FG(3,CURN).EQ.0) THEN
C SLC or EXIT
            CONTRL=STSLC(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,
     +                   STKSIZ,SP,PUROOT)
        ELSE IF (FG(1,CURN).EQ.-1) THEN
C REPEAT
            CONTRL=STRPT(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,MAXSP,
     +                   LNUM)
        ELSE IF (FG(2,CURN).LT.0) THEN
C CASE
            TMP=-FG(2,CURN)-1
            IF (FG(1,CURN).LT.0) THEN
C simulated case to handle ENTRY points
            ELSE IF (ZYNTYP(FG(1,CURN)).EQ.52) THEN
C   - part 1: fix the statement up so the label refs are correct
                PTR=ZYDOWN(FG(1,CURN))
                IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
                PTR=ZYDOWN(PTR)
                DO 250 I=1-FG(3,CURN),TMP-FG(3,CURN)
                    CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,PTR)
                    PTR=ZYNEXT(PTR)
 250            CONTINUE
            ELSE IF (ZYNTYP(FG(1,CURN)).EQ.55) THEN
                IF (TMP.NE.2) CALL ERROR('STRUCP: INVALID ARITHIF')
                PTR=ZYDOWN(FG(1,CURN))
                IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
                PTR=ZYNEXT(PTR)
                DO 255 I=-FG(3,CURN),TMP-FG(3,CURN)
                    CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,PTR)
                    PTR=ZYNEXT(PTR)
 255            CONTINUE
            ELSE IF (ZYNTYP(FG(1,CURN)).EQ.82) THEN
                PTR=ZYDOWN(FG(1,CURN))
                DO 258 I=1-FG(3,CURN),TMP-FG(3,CURN)
 257                PTR=ZYNEXT(PTR)
                    IF (ZYNTYP(PTR).NE.116) GOTO 257
                    CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,PTR)
 258            CONTINUE
            ELSE
                PTR=ZYDOWN(FG(1,CURN))
                I=1-FG(3,CURN)
 260            IF (ZYNTYP(PTR).NE.68) THEN
                    PTR=ZYNEXT(PTR)
                    GOTO 260
                END IF
                PTR=ZYDOWN(PTR)
 270            IF (ZYNTYP(PTR).EQ.69) THEN
                    CALL ZYGTST(-ZYDOWN(ZYDOWN(PTR)),TEXT)
                    IF (EQUAL(TEXT,ENDKD).EQ.-2 .OR.
     +                  EQUAL(TEXT,ERRKD).EQ.-2) THEN
                        CALL MKLREF(FG,FGSIZE,CASETB(I),LNUM,
     +                              ZYNEXT(ZYDOWN(PTR)))
                        I=I+1
                    END IF
                END IF
                PTR=ZYNEXT(PTR)
                IF (PTR.NE.0) GOTO 270
            END IF
C   - Part 2: Output the modified statement
            IF (FG(1,CURN).GT.0) THEN
                CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
                CALL YSTMT(FG(1,CURN),DESCO)
            END IF
C   - Part 3: Stack call so we stack the followers later
            CALL GFPUSH(STACK,STKSIZ,SP,CURN,5,LOOPL,MAXSP)
C   - Part 4: Stack calls to process the descendents in order
C             (being careful not to stack two copies of one node!)
C             (also don't stack calls for backward pointers!)
            DO 280 I=TMP-FG(3,CURN),-FG(3,CURN),-1
                IF (FG(8,CASETB(I)).EQ.0 .AND.
     +              FG(4,CASETB(I)).GT.FG(4,CURN)) THEN
                    CALL GFPUSH(STACK,STKSIZ,SP,CASETB(I),1,LOOPL,MAXSP)
                    FG(8,CASETB(I))=-1
                END IF
 280        CONTINUE
            DO 290 I=TMP-FG(3,CURN),-FG(3,CURN),-1
                IF (FG(8,CASETB(I)).EQ.-1)
     +              FG(8,CASETB(I))=0
 290        CONTINUE
C   - Part 5: Fixup default control flow
            IF (FG(1,CURN).GT.0) THEN
              IF (ZYNTYP(FG(1,CURN)).NE.55 .AND.
     +          NEXTND(FG,FGSIZE,-1,STACK,STKSIZ,SP).NE.
     +          CASETB(-FG(3,CURN)))
     +          CALL GOTOX(FG,FGSIZE,CASETB(-FG(3,CURN)),
     +                     LNUM,DESCO)
            ENDIF
C   - Part 6: Return from GETFORM
            CONTRL=7
        ELSE IF (ZYNTYP(FG(1,CURN)).EQ.61) THEN
C IF (actually DO)
            CONTRL=STDO(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,STKSIZ,
     +                  SP,MAXSP)
        ELSE
C IF (not a DO)
            CONTRL=STIF(FG,FGSIZE,CURN,IODCMT,DESCO,STACK,STKSIZ,SP,
     +                  LNUM,MAXSP)
        END IF
        GOTO 100
C
C END OF REPEAT LOOP
C
 300    CONTRL=STXRPT(FG,FGSIZE,CURN,LOOPL,DESCO,STACK,STKSIZ,SP,LNUM,
     +                MAXSP)
        GOTO 100
C
C MIDDLE OF IF TEST
C
 400    CONTRL=STIF2(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,LNUM,
     +                  MAXSP)
        GOTO 100
C
C END OF IF BLOCK
C
 500    CONTRL=STIF3(DESCO)
        GOTO 100
C
C TRANSFER OF CONTROL (SINGLETON REACH SET)
C
 600    CALL GOTOX(FG,FGSIZE,CURN,LNUM,DESCO)
        CONTRL=7
        GOTO 100
C
C Final part of GETFORM: stack calls to do all "follow" nodes
C
1000    CALL STKFOL(FG,FGSIZE,CURN,STACK,STKSIZ,SP,MAXSP)
C
C End of "GETFORM" -- pop call stack and go to it.
C
1500    IF (SP.GT.0) THEN
            CURN=STACK(1,SP)
            CONTRL=STACK(2,SP)
            LOOPL=STACK(3,SP)
            SP=SP-1
            GOTO 100
        END IF
C
C If we have reached here then we have finished
C
        IF (TRACE) THEN
            CALL ZCHOUT('[Trace: STRUCT stack usage = ',2)
            CALL ZPTINT(MAXSP,1,2)
            CALL ZMESS(']',2)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       O D R F D O   -   Output Declaratives, relabel Formats and
C                         Delabel Others.
C
 
        SUBROUTINE ODRFDO(PUPTR,IODCMT,DESCO)
        INTEGER PUPTR,IODCMT,DESCO
 
        INTEGER NONEXE,EXE
        PARAMETER (NONEXE=0,EXE=1)
 
        INTEGER STTYPE(132),STPTR,PTR,I,LTEXT(8),LNUM
 
        SAVE STTYPE
 
        INTEGER ZYDOWN,ZYNTYP,ZYNEXT,ITOC,ZYASTR
        EXTERNAL ZYDOWN,ZYNTYP,ZYNEXT,ITOC,ZYASTR,ZYSATT,ZYDELT,YSTMT
 
        DATA STTYPE(7),STTYPE(8),STTYPE(16),
     +       STTYPE(20),STTYPE(24),STTYPE(26),
     +       STTYPE(30),STTYPE(35),STTYPE(37),
     +       STTYPE(38),STTYPE(39),STTYPE(41),
     +       STTYPE(78),STTYPE(121)
     +       /14*NONEXE/
        DATA STTYPE(18),STTYPE(49),STTYPE(131),
     +       STTYPE(63),STTYPE(64),STTYPE(67),
     +       STTYPE(82),STTYPE(50),STTYPE(6),
     +       STTYPE(65),STTYPE(66),STTYPE(72),
     +       STTYPE(73),STTYPE(74),STTYPE(75),
     +       STTYPE(52),STTYPE(53),STTYPE(55),
     +       STTYPE(76),STTYPE(77),STTYPE(51),
     +       STTYPE(56),STTYPE(57),STTYPE(58),
     +       STTYPE(59),STTYPE(60),STTYPE(62),
     +       STTYPE(83),STTYPE(61),STTYPE(132)
     +       /30*EXE/
 
        STPTR=ZYDOWN(PUPTR)
        LNUM=9000
 100    PTR=ZYDOWN(STPTR)
        IF (ZYNTYP(STPTR).EQ.78) THEN
C Number FORMAT starting from 9000 (we don't care a whit about the
C resultant destruction of the symbol table) in steps of 10.
            I=ITOC(LNUM,LTEXT,7)
            LNUM=LNUM+10
            CALL ZYSATT(-ZYDOWN(PTR),2,ZYASTR(LTEXT))
        ELSE
C Delete all other labels in the program-unit as we will create our own
            IF (PTR.NE.0) THEN
                IF (ZYNTYP(PTR).EQ.115) CALL ZYDELT(PTR)
            END IF
C Output non-executable non-FORMAT statements (declarations).
            IF (STTYPE(ZYNTYP(STPTR)).EQ.NONEXE) THEN
                CALL COMMNT(STPTR,IODCMT,DESCO)
                CALL YSTMT(STPTR,DESCO)
            END IF
        END IF
        STPTR=ZYNEXT(STPTR)
        IF (STPTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       G F P U S H   -   Push stack frame for GETFORM
C
 
        SUBROUTINE GFPUSH(STACK,STKSIZ,SP,CURN,JUMP,LOOP,MAXSP)
        INTEGER STKSIZ,SP,CURN,JUMP,LOOP,MAXSP
        INTEGER STACK(3,STKSIZ)
 
        EXTERNAL ERROR
 
        IF (SP.EQ.STKSIZ) CALL ERROR('STRUCT stack overflow')
        SP=SP+1
        MAXSP=MAX(SP,MAXSP)
        STACK(1,SP)=CURN
        STACK(2,SP)=JUMP
        STACK(3,SP)=LOOP
 
        END
C ----------------------------------------------------------------------
C
C       S T S L C   -   Structure: SLC node
C
 
        INTEGER FUNCTION STSLC(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,
     +                         STKSIZ,SP,PUROOT)
        INTEGER CURN,FGSIZE,LNUM,IODCMT,DESCO,STKSIZ,SP,PUROOT
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
        INTEGER NEXTND
 
        INTEGER ZYNTYP,ZYDOWN
        EXTERNAL ZYNTYP,ZYDOWN,ZYCHNT,YSTMT,REMARK
 
        CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
C if (END statement) then output FORMAT statements first, and also
C check for dead code being eliminated...
        IF (ZYNTYP(FG(1,CURN)).EQ.6) THEN
            CALL OUTFMT(PUROOT,IODCMT,DESCO)
            CALL CKDEAD(FG,FGSIZE,PUROOT,IODCMT,DESCO)
        END IF
        IF (ZYNTYP(FG(1,CURN)).NE.131) THEN
            CALL YSTMT(FG(1,CURN),DESCO)
        ELSE IF (ZYDOWN(FG(1,CURN)).NE.0) THEN
            CALL ZYCHNT(FG(1,CURN),62)
            CALL YSTMT(FG(1,CURN),DESCO)
        END IF
        IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
     +      FG(2,CURN) .AND.
     +      ZYNTYP(FG(1,CURN)).NE.83 .AND.
     +      ZYNTYP(FG(1,CURN)).NE.63) THEN
C This does "FIXCONTROL" on the fly (the only way it should be done!)
            IF (ZYNTYP(FG(1,CURN)).EQ.6) THEN
                CALL REMARK(
     +'Internal Error: END statement is in the wrong place')
            ELSE IF (FG(2,CURN).NE.0) THEN
                CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,DESCO)
            END IF
        END IF
        STSLC=5
 
        END
C ----------------------------------------------------------------------
C
C       S T R P T   -   Structure: REPEAT node
C
 
        INTEGER FUNCTION STRPT(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,
     +                         MAXSP,LNUM)
        INTEGER FGSIZE,CURN,DESCO,STKSIZ,SP,MAXSP,LNUM
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER TMP,LOOPL,LTEXT(8),I
 
        INTEGER ITOC,ZYNTYP
        EXTERNAL ITOC,ZYNTYP,ZUSCAN
 
        TMP=FG(1,FG(2,CURN))
        IF (TMP.GT.0) THEN
            IF (ZYNTYP(TMP).NE.61) TMP=-1
        END IF
        IF (FG(3,CURN).EQ.0) THEN
            LNUM=LNUM+10
            IF (LNUM.EQ.9000) LNUM=90000
            IF (TMP.LE.0) THEN
                I=ITOC(LNUM,LTEXT,7)
                CALL ZUSCAN(TDCNST,I,LTEXT,DESCO)
                LTEXT(1)=129
                CALL ZUSCAN(TCONTI,0,LTEXT,DESCO)
                CALL ZUSCAN(TZEOS,0,LTEXT,DESCO)
                LOOPL=LNUM
            ELSE
                LOOPL=-LNUM
            END IF
            FG(3,CURN)=LOOPL
        ELSE
C label already assigned to this repeat - use it
            LOOPL=FG(3,CURN)
            IF (LOOPL.GT.0) THEN
                I=ITOC(LOOPL,LTEXT,7)
                CALL ZUSCAN(TDCNST,I,LTEXT,DESCO)
                LTEXT(1)=129
                CALL ZUSCAN(TCONTI,0,LTEXT,DESCO)
                CALL ZUSCAN(TZEOS,0,LTEXT,DESCO)
            END IF
        END IF
C If "q" not in any follow set then make a recursive call
        IF (FG(8,FG(2,CURN)).EQ.0) THEN
            CALL GFPUSH(STACK,STKSIZ,SP,CURN,2,LOOPL,MAXSP)
            CURN=FG(2,CURN)
            STRPT=1
        ELSE
            STRPT=2
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       S T D O   -   Structure: DO statement node
C
 
        INTEGER FUNCTION STDO(FG,FGSIZE,CURN,LNUM,IODCMT,DESCO,STACK,
     +                        STKSIZ,SP,MAXSP)
        INTEGER FGSIZE,CURN,LNUM,IODCMT,DESCO,STKSIZ,MAXSP,SP
        INTEGER FG(8,FGSIZE),STACK(MAXSP)
 
        INTEGER LTEXT(8),I,PTR
 
        INTEGER ITOC,ZYDOWN,ZYNTYP,ZYNEXT,ZYASYM,ZYASTR
        EXTERNAL ITOC,ZYDOWN,ZYNTYP,ZYNEXT,ZYASYM,ZYASTR,ERROR,ZYCHDN,
     +           YSTMT
 
C Check for DO which is not a loop
        IF (FG(4,FG(2,CURN)).LT.FG(4,CURN).OR.
     +      FG(8,FG(2,CURN)).NE.0) THEN
            CALL ERROUT('Warning: DO non-loop found',FG(1,CURN))
            LNUM=LNUM+10
            IF (LNUM.EQ.9000) LNUM=90000
        END IF
        I=ITOC(LNUM,LTEXT,7)
        PTR=ZYDOWN(FG(1,CURN))
        IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
        IF (ZYNTYP(PTR).NE.116) CALL ERROR('OOPS!')
        CALL ZYCHDN(PTR,-ZYASYM(ZYASTR(LTEXT),1,1))
        CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
        CALL YSTMT(FG(1,CURN),DESCO)
C Non-looping DO?
        IF (FG(4,FG(2,CURN)).LT.FG(4,CURN).OR.
     +      FG(8,FG(2,CURN)).NE.0) THEN
            CALL GFPUSH(STACK,STKSIZ,SP,CURN,2,-LNUM,MAXSP)
            IF (FG(8,FG(2,CURN)).EQ.0) THEN
                CURN=FG(2,CURN)
                STDO=1
            ELSE
                CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,DESCO)
                STDO=7
            END IF
        ELSE
C (GFPUSH done in repeat node processing already)
            CURN=FG(2,CURN)
            STDO=1
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       S T I F   -   Structure: an IF node
C
 
        INTEGER FUNCTION STIF(FG,FGSIZE,CURN,IODCMT,DESCO,STACK,STKSIZ,
     +                        SP,LNUM,MAXSP)
        INTEGER FGSIZE,CURN,IODCMT,DESCO,STKSIZ,SP,LNUM,MAXSP
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        LOGICAL LOGIFS
        PARAMETER (LOGIFS=.TRUE.)
 
        INTEGER TMP,PTR,DUMMY(2)
        LOGICAL LTMP,LTMP2
 
        SAVE DUMMY
 
        INTEGER NEXTND,FOLLOW
 
        INTEGER ZYNTYP,ZYDOWN,ZYNEXT
        EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYCHNT,YLEAF,ZUSCAN,YEXPR,YSTMT
 
        DATA DUMMY/129,129/
 
        STIF=5
        IF (ZYNTYP(FG(1,CURN)).NE.132+1) THEN
            CALL ZYCHNT(FG(1,CURN),57)
            IF (FOLLOW(FG,FGSIZE,CURN).EQ.0)
     +          CALL REACH(FG,FGSIZE,CURN,
     +                     NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP),
     +                    STACK,STKSIZ,SP,MAXSP)
        ELSE
            CALL ZYCHNT(FG(1,CURN),58)
        END IF
C Simplify logical expressions by removing extra parentheses around them
        PTR=ZYDOWN(FG(1,CURN))
 100    IF (ZYNTYP(PTR).EQ.101) THEN
            TMP=ZYDOWN(PTR)
            CALL ZYREPL(PTR,TMP)
            PTR=TMP
            GOTO 100
        END IF
C Check for logical expression beginning with .NOT. and invert it if so
C (so we can simplify logical expressions we wouldn't touch otherwise
        IF (ZYNTYP(ZYDOWN(FG(1,CURN))).EQ.88)
     +      CALL INVERT(FG,FGSIZE,CURN)
C Test for 'ifless else' and turn it into an 'elseless if'
        IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).EQ.
     +      FG(2,CURN)) THEN
C But not if both ifless and elseless
            IF (FG(2,CURN).NE.FG(3,CURN)) THEN
                CALL INVERT(FG,FGSIZE,CURN)
            ELSE
                CALL ERROUT('Warning: IF stmt has null effect',
     +                      FG(1,CURN))
            END IF
C Also check for possibility of an ELSEIF construction
C (but not if it is an elseless if)
        ELSE IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
     +           FG(3,CURN) .AND.
     +           FG(4,FG(2,CURN)).GE.FG(4,CURN)
     +           .AND. FG(8,FG(2,CURN)).EQ.0) THEN
C Set LTMP == ELSEIF should be generated if the arcs are reversed
C Set LTMP2 == ELSEIF should be generated anyway
C (only reverse arcs if it improves things, not just for fun!)
            LTMP=FG(2,FG(2,CURN)).GT.0 .AND.
     +           FG(3,FG(2,CURN)).GT.0 .AND.
     +           FOLLOW(FG,FGSIZE,FG(2,CURN)).EQ.0
            IF (LTMP)
     +          LTMP=ZYNTYP(FG(1,FG(2,CURN))).NE.61
            LTMP2=FG(4,FG(3,CURN)).GT.FG(4,CURN)
     +            .AND. FG(8,FG(3,CURN)).EQ.0
            IF (LTMP2)
     +          LTMP2=FG(2,FG(3,CURN)).GT.0 .AND.
     +                FG(3,FG(3,CURN)).GT.0 .AND.
     +                FOLLOW(FG,FGSIZE,FG(3,CURN)).EQ.0
            IF (LTMP2)
     +          LTMP2=ZYNTYP(FG(1,FG(3,CURN))).NE.61
 
            IF (LTMP .AND. .NOT.LTMP2) CALL INVERT(FG,FGSIZE,CURN)
        END IF
C If it is an elseless if ... and the if part is not nested inside
C the if ... i.e. it will become an if-goto ... make it a logical
C if-goto not the clumsy if-then goto end-if.
C P.S. Make sure not an ELSEIF though since we can't do it then...
        IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).EQ.
     +      FG(3,CURN) .AND.
     +      ZYNTYP(FG(1,CURN)).EQ.57 .AND.
     +      (FG(8,FG(2,CURN)).NE.0 .OR.
     +      FG(4,FG(2,CURN)).LE.FG(4,CURN)))
     +  THEN
            CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
C Also, this effectively makes this into an slc so
            PTR=ZYDOWN(FG(1,CURN))
            IF (ZYNTYP(PTR).EQ.115) THEN
                CALL YLEAF(PTR,DESCO)
                PTR=ZYNEXT(PTR)
            END IF
            CALL ZUSCAN(TIF,0,DUMMY,DESCO)
            CALL ZUSCAN(TLPARN,0,DUMMY,DESCO)
            CALL YEXPR(PTR,DESCO)
            CALL ZUSCAN(TRPARN,0,DUMMY,DESCO)
            CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,DESCO)
        ELSE IF (LOGIFS .AND.
     +           NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).EQ.
     +           FG(3,CURN) .AND.
     +           ZYNTYP(FG(1,CURN)).EQ.57 .AND.
     +           FG(2,FG(2,CURN)).EQ.FG(3,CURN)
     +           .AND. FG(3,FG(2,CURN)).EQ.0 .AND.
     +           FG(7,FG(2,CURN)).EQ.1) THEN
C Produce logical IF but .. check for only a comment as consequence
            CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
            IF (FG(1,FG(2,CURN)).LE.0)
     +          CALL ERROR('INVALID IF STATEMENT')
            IF (ZYNTYP(FG(1,FG(2,CURN))).NE.131)
     +          CALL COMMNT(FG(1,FG(2,CURN)),IODCMT,DESCO)
            PTR=ZYDOWN(FG(1,CURN))
            IF (ZYNTYP(PTR).EQ.115) THEN
                CALL YLEAF(PTR,DESCO)
                PTR=ZYNEXT(PTR)
            END IF
            CALL ZUSCAN(TIF,0,DUMMY,DESCO)
            CALL ZUSCAN(TLPARN,0,DUMMY,DESCO)
            CALL YEXPR(PTR,DESCO)
            CALL ZUSCAN(TRPARN,0,DUMMY,DESCO)
            IF (ZYNTYP(FG(1,FG(2,CURN))).NE.131)
     +      THEN
                CALL YSTMT(FG(1,FG(2,CURN)),DESCO)
            ELSE
                CALL ZUSCAN(TTHEN,0,DUMMY,DESCO)
                CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
                CALL COMMNT(FG(1,FG(2,CURN)),IODCMT,DESCO)
                CALL ZUSCAN(TENDIF,0,DUMMY,DESCO)
                CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
                CALL ERROUT('Warning: IF consequence is a comment',
     +                      FG(1,CURN))
            END IF
        ELSE
            CALL COMMNT(FG(1,CURN),IODCMT,DESCO)
            CALL YSTMT(FG(1,CURN),DESCO)
            IF (FG(4,FG(2,CURN)).GE.FG(4,CURN)
     +          .AND. FG(8,FG(2,CURN)).EQ.0) THEN
                CALL GFPUSH(STACK,STKSIZ,SP,CURN,3,0,MAXSP)
                CURN=FG(2,CURN)
                STIF=1
            ELSE
                IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
     +              FG(2,CURN)) THEN
C This does "FIXCONTROL" on the fly (the only way it should be done!)
                    CALL GOTOX(FG,FGSIZE,FG(2,CURN),LNUM,
     +                         DESCO)
                END IF
                STIF=3
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       I N V E R T   -   Invert the form of an IF, preserving semantics
C
 
        SUBROUTINE INVERT(FG,FGSIZE,CURN)
        INTEGER FGSIZE,CURN
        INTEGER FG(8,FGSIZE)
 
        INTEGER TMP
 
        INTEGER ZYDOWN,ZYNTYP,ZYNEXT
        EXTERNAL ZYDOWN,ZYNTYP,ZYNEXT
 
C --Found one, swap the outarcs
        TMP=FG(2,CURN)
        FG(2,CURN)=FG(3,CURN)
        FG(3,CURN)=TMP
C --Now invert the condition
        TMP=ZYDOWN(FG(1,CURN))
        IF (ZYNTYP(TMP).EQ.115) TMP=ZYNEXT(TMP)
        CALL INVCON(TMP)
 
        END
C ----------------------------------------------------------------------
C
C       S T X R P T   -   Structure: End a repeat loop
C
 
        INTEGER FUNCTION STXRPT(FG,FGSIZE,CURN,LOOPL,DESCO,STACK,STKSIZ,
     +                          SP,LNUM,MAXSP)
        INTEGER FGSIZE,CURN,LOOPL,DESCO,STKSIZ,SP,LNUM,MAXSP
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER LTEXT(8),I
 
        INTEGER NEXTND
 
        INTEGER ITOC
        EXTERNAL ITOC,ZUSCAN
 
        STXRPT=5
        IF (LOOPL.LT.0) THEN
C Only terminate DO-loops; force explicit control xfers for others
            I=ITOC(-LOOPL,LTEXT,7)
            CALL ZUSCAN(TDCNST,I,LTEXT,DESCO)
            LTEXT(1)=129
            CALL ZUSCAN(TCONTI,0,LTEXT,DESCO)
            CALL ZUSCAN(TZEOS,0,LTEXT,DESCO)
C Fixup control flow if necessary
C Check for non-looping DO
            IF (FG(1,CURN).NE.-1) THEN
                IF (FG(4,FG(3,CURN)).GE.
     +              FG(4,CURN) .AND.
     +              FG(8,FG(3,CURN)).EQ.0) THEN
C ... stack followers because we handle the false outarc now.
C (this is equivalent to handling the false outarc recursively)
                    CALL STKFOL(FG,FGSIZE,CURN,STACK,STKSIZ,SP,MAXSP)
                    CURN=FG(3,CURN)
                    STXRPT=1
                ELSE IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
     +                   FG(3,CURN)) THEN
                    CALL GOTOX(FG,FGSIZE,FG(3,CURN),LNUM,DESCO)
                END IF
            ELSE IF (FG(3,FG(2,CURN)).NE.
     +               NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP)) THEN
                CALL GOTOX(FG,FGSIZE,FG(3,FG(2,CURN)),
     +                     LNUM,DESCO)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       S T I F 2   -   Structure: IF node part 2 (else clause)
C
 
        INTEGER FUNCTION STIF2(FG,FGSIZE,CURN,DESCO,STACK,STKSIZ,SP,
     +                         LNUM,MAXSP)
        INTEGER FGSIZE,CURN,DESCO,STKSIZ,SP,LNUM,MAXSP
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER DUMMY(2)
        LOGICAL LTMP
 
        SAVE DUMMY
 
        INTEGER NEXTND,FOLLOW
 
        INTEGER ZYNTYP
        EXTERNAL ZYNTYP,ZYCHNT,ZUSCAN
 
        DATA DUMMY/129,129/
 
        STIF2=4
        IF (FG(4,FG(3,CURN)).GE.FG(4,CURN)
     +          .AND. FG(8,FG(3,CURN)).EQ.0) THEN
C Check for ELSEIF possibility:
C   if next node is an IF (not a DO) and its follow set is null
            LTMP=FG(2,FG(3,CURN)).GT.0 .AND.
     +           FG(3,FG(3,CURN)).GT.0 .AND.
     +           FOLLOW(FG,FGSIZE,FG(3,CURN)).EQ.0
            IF (LTMP)
     +          LTMP=ZYNTYP(FG(1,FG(3,CURN))).NE.61
            IF (LTMP) THEN
                CALL ZYCHNT(FG(1,FG(3,CURN)),
     +                      132+1)
                CALL GFPUSH(STACK,STKSIZ,SP,CURN,5,0,MAXSP)
            ELSE
                CALL ZUSCAN(TELSE,0,DUMMY,DESCO)
                CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
                CALL GFPUSH(STACK,STKSIZ,SP,CURN,4,0,MAXSP)
            END IF
            CURN=FG(3,CURN)
            STIF2=1
        ELSE IF (NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP).NE.
     +           FG(3,CURN)) THEN
            CALL ZUSCAN(TELSE,0,DUMMY,DESCO)
            CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
C This does "FIXCONTROL" on the fly (the only way it should be done!)
            CALL GOTOX(FG,FGSIZE,FG(3,CURN),LNUM,DESCO)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       S T I F 3   -   Structure IF node: pt 3 (close off the IF block)
C
 
        INTEGER FUNCTION STIF3(DESCO)
        INTEGER DESCO
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER DUMMY(2)
 
        SAVE DUMMY
 
        EXTERNAL ZUSCAN
 
        DATA DUMMY/129,129/
 
        CALL ZUSCAN(TENDIF,0,DUMMY,DESCO)
        CALL ZUSCAN(TZEOS,0,DUMMY,DESCO)
        STIF3=5
 
        END
C ----------------------------------------------------------------------
C
C       S T K F O L   -   Stack calls to process "following" nodes
C
 
        SUBROUTINE STKFOL(FG,FGSIZE,CURN,STACK,STKSIZ,SP,MAXSP)
        INTEGER CURN,FGSIZE,STKSIZ,SP,MAXSP
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
        INTEGER I,J,TMP,TMP3(3),PTR
 
        TMP=SP+1
        DO 100 I=1,FGSIZE
            IF (FG(8,I).EQ.CURN) THEN
                CALL GFPUSH(STACK,STKSIZ,SP,I,1,0,MAXSP)
            END IF
 100    CONTINUE
C
C Must sort stacked calls into "L" order, i.e. on FG(fg_number,*)
C
C Just use insertion sort as it is quite easy
C
        DO 400 I=TMP+1,SP
            PTR=TMP
 200        IF (FG(4,STACK(1,PTR)).GE.
     +          FG(4,STACK(1,I))) THEN
                PTR=PTR+1
                IF (PTR.LT.I) GOTO 200
            ELSE
                TMP3(1)=STACK(1,I)
                TMP3(2)=STACK(2,I)
                TMP3(3)=STACK(3,I)
                DO 300 J=I,PTR+1,-1
                    STACK(1,J)=STACK(1,J-1)
                    STACK(2,J)=STACK(2,J-1)
                    STACK(3,J)=STACK(3,J-1)
 300            CONTINUE
                STACK(1,PTR)=TMP3(1)
                STACK(2,PTR)=TMP3(2)
                STACK(3,PTR)=TMP3(3)
            END IF
 400    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       F O L L O W   -   Return the first node in the FOLLOW set
C
 
        INTEGER FUNCTION FOLLOW(FG,FGSIZE,NODE)
        INTEGER FGSIZE,NODE
        INTEGER FG(8,FGSIZE)
 
        INTEGER I
 
        FOLLOW=0
        I=1
 100    IF (FG(8,I).EQ.NODE) THEN
            IF (FOLLOW.EQ.0) THEN
                FOLLOW=I
            ELSE IF (FG(4,I).LT.FG(4,FOLLOW)) THEN
                FOLLOW=I
            END IF
        END IF
        IF (I.LT.FGSIZE) THEN
            I=I+1
            GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       N E X T N D   -   Return the next node which will be output
C
 
        INTEGER FUNCTION NEXTND(FG,FGSIZE,CURN,STACK,STKSIZ,SP)
        INTEGER FGSIZE,CURN,STKSIZ,SP
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
        INTEGER I
 
        INTEGER FOLLOW
 
        NEXTND=FOLLOW(FG,FGSIZE,CURN)
        IF (NEXTND.EQ.0 .AND. SP.GT.0) THEN
            I=SP
 100        NEXTND=STACK(1,I)
            IF (STACK(2,I).EQ.3 .OR. STACK(2,I).EQ.4 .OR.
     +          STACK(2,I).EQ.5 .OR.
     +          STACK(2,I).EQ.2 .AND. STACK(3,I).GT.0) THEN
C at end of if clauses we jump to the follower of the if statement
C at end of repeat (not DO) we pass to the follower of the repeat
                NEXTND=FOLLOW(FG,FGSIZE,NEXTND)
C if no follower we are ending several blocks at once ...
                IF (NEXTND.EQ.0 .AND. I.GT.1) THEN
                    I=I-1
                    GOTO 100
                END IF
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       G O T O X   -   Add GOTO statement to output
C
 
        SUBROUTINE GOTOX(FG,FGSIZE,NODE,LABNUM,TKDESC)
        INTEGER FGSIZE,NODE,LABNUM,TKDESC
        INTEGER FG(8,FGSIZE)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER TEXT(8),I
        LOGICAL USERET
 
        INTEGER LABELN
 
        INTEGER ITOC,ZYNTYP,ZYUP
        EXTERNAL ITOC,ZYNTYP,ZYUP,ZUSCAN
 
        TEXT(1)=129
        USERET=FG(1,NODE).GT.0
        IF (USERET) USERET=ZYNTYP(FG(1,NODE)).EQ.6 .AND.
     +                     ZYNTYP(ZYUP(FG(1,NODE))).NE.2
        IF (USERET) THEN
            CALL ZUSCAN(TRETUR,0,TEXT,TKDESC)
        ELSE
            CALL ZUSCAN(TGOTO,0,TEXT,TKDESC)
            I=ITOC(LABELN(FG,FGSIZE,NODE,LABNUM),TEXT,7)
            CALL ZUSCAN(TDCNST,I,TEXT,TKDESC)
            TEXT(1)=129
        END IF
        CALL ZUSCAN(TZEOS,0,TEXT,TKDESC)
 
        END
C ----------------------------------------------------------------------
C
C       M K L R E F   -   Make a N_LABELREF node point correctly
C
 
        SUBROUTINE MKLREF(FG,FGSIZE,FGNODE,LABNUM,PTNODE)
        INTEGER FGSIZE,FGNODE,LABNUM,PTNODE
        INTEGER FG(8,FGSIZE)
 
        INTEGER I,TEXT(8)
 
        INTEGER LABELN
 
        INTEGER ITOC,ZYASTR,ZYASYM
        EXTERNAL ITOC,ZYASTR,ZYASYM,ZYCHDN
 
        I=ITOC(LABELN(FG,FGSIZE,FGNODE,LABNUM),TEXT,7)
        CALL ZYCHDN(PTNODE,-ZYASYM(ZYASTR(TEXT),1,1))
 
        END
C ----------------------------------------------------------------------
C
C       L A B E L N   -   Label a node (return value)
C
 
        INTEGER FUNCTION LABELN(FG,FGSIZE,NODE,LABNUM)
        INTEGER FGSIZE,NODE,LABNUM
        INTEGER FG(8,FGSIZE)
 
        INTEGER TEXT(134),SYMBOL(8),I,PTNODE,PTR
 
        INTEGER ZYNEXT,ZYDOWN,ZYNTYP,ZYCRND,ZYASTR,ZYASYM,ITOC,CTOI
        EXTERNAL ZYNEXT,ZYDOWN,ZYNTYP,ZYCRND,ZYASTR,ZYASYM,ITOC,CTOI,
     +           ZYADSN,ZYGTSY,ZYGTST,ERROR,ZYADNX
 
        PTNODE=FG(1,NODE)
        IF (PTNODE.LT.0) THEN
            IF (FG(3,NODE).EQ.0) THEN
                LABNUM=LABNUM+10
                IF (LABNUM.EQ.9000) LABNUM=90000
C Must check for DO - in which case label the DO not the repeat node?
                PTNODE=FG(1,FG(2,NODE))
                IF (PTNODE.LE.0) CALL ERROR('LABELN: BAD REPEAT')
                IF (ZYNTYP(PTNODE).EQ.61) THEN
                    PTR=ZYDOWN(PTNODE)
                    IF (ZYNTYP(PTR).EQ.115) THEN
                        IF (LABNUM.EQ.90000) LABNUM=9000
                        LABNUM=LABNUM-10
                        CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTNODE)),SYMBOL)
                        CALL ZYGTST(SYMBOL(2),TEXT)
                        I=1
                        LABELN=CTOI(TEXT,I)
                    ELSE
                        I=ITOC(LABNUM,TEXT,7)
                        CALL ZYADNX(ZYCRND(115,
     +                                     -ZYASYM(ZYASTR(TEXT),
     +                                             1,
     +                                             1)),
     +                              ZYDOWN(PTNODE))
                        CALL ZYADNX(ZYDOWN(PTNODE),
     +                              ZYNEXT(ZYDOWN(PTNODE)))
                        LABELN=LABNUM
                    END IF
                ELSE
                    FG(3,NODE)=LABNUM
                    LABELN=ABS(FG(3,NODE))
                END IF
            ELSE
                LABELN=ABS(FG(3,NODE))
            END IF
        ELSE IF (ZYDOWN(PTNODE).LE.0) THEN
            LABNUM=LABNUM+10
            IF (LABNUM.EQ.9000) LABNUM=90000
            I=ITOC(LABNUM,TEXT,7)
            CALL ZYADSN(PTNODE,ZYCRND(115,
     +                                -ZYASYM(ZYASTR(TEXT),1,1)))
            LABELN=LABNUM
        ELSE IF (ZYNTYP(ZYDOWN(PTNODE)).EQ.115) THEN
            CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTNODE)),SYMBOL)
            CALL ZYGTST(SYMBOL(2),TEXT)
            I=1
            LABELN=CTOI(TEXT,I)
        ELSE
            LABNUM=LABNUM+10
            IF (LABNUM.EQ.9000) LABNUM=90000
            I=ITOC(LABNUM,TEXT,7)
            CALL ZYADNX(ZYCRND(115,
     +                         -ZYASYM(ZYASTR(TEXT),1,1)),
     +                  ZYDOWN(PTNODE))
            CALL ZYADNX(ZYDOWN(PTNODE),ZYNEXT(ZYDOWN(PTNODE)))
            LABELN=LABNUM
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       I N V C O N   -   Invert a condition
C
 
        SUBROUTINE INVCON(COND)
        INTEGER COND
 
        INTEGER STKSIZ
        PARAMETER(STKSIZ=15)
 
        INTEGER NODE,TMP,TMP2,STACK(STKSIZ),SP
 
        INTEGER ZYNTYP,ZYCRND,ZYDOWN,ZYNEXT
        EXTERNAL ZYNTYP,ZYCRND,ZYDOWN,ZYNEXT,ZYCHNT,ZYREPL,ZYADSN,REMARK
 
        NODE=COND
        SP=0
C Negate this subexpression
 100    IF (ZYNTYP(NODE).EQ.91) THEN
            CALL ZYCHNT(NODE,92)
        ELSE IF (ZYNTYP(NODE).EQ.92) THEN
            CALL ZYCHNT(NODE,91)
        ELSE IF (ZYNTYP(NODE).EQ.90) THEN
            CALL ZYCHNT(NODE,93)
        ELSE IF (ZYNTYP(NODE).EQ.89) THEN
            CALL ZYCHNT(NODE,94)
        ELSE IF (ZYNTYP(NODE).EQ.94) THEN
            CALL ZYCHNT(NODE,89)
        ELSE IF (ZYNTYP(NODE).EQ.93) THEN
            CALL ZYCHNT(NODE,90)
        ELSE IF (ZYNTYP(NODE).EQ.84) THEN
            CALL ZYCHNT(NODE,85)
        ELSE IF (ZYNTYP(NODE).EQ.85) THEN
            CALL ZYCHNT(NODE,84)
        ELSE IF (ZYNTYP(NODE).EQ.88) THEN
            TMP=ZYDOWN(NODE)
            CALL ZYREPL(NODE,TMP)
        ELSE IF (ZYNTYP(NODE).EQ.86 .OR.
     +           ZYNTYP(NODE).EQ.87) THEN
C Apply distributive law: NOT(A OR B) = NOT(A) AND NOT(B)
C                     or: NOT(A AND B) = NOT(A) AND NOT(B)
C (but not if the both sub-expressions are simple -- we would rather
C  get .NOT.(A.OR.B) than .NOT.A.AND..NOT.B; simple extends to being
C  other conjunctions or disjunctions since we can't simplify them
C  either)
            IF ((ZYNTYP(ZYDOWN(NODE)).EQ.104 .OR.
     +          ZYNTYP(ZYDOWN(NODE)).EQ.108 .OR.
     +          ZYNTYP(ZYDOWN(NODE)).EQ.119 .OR.
     +          ZYNTYP(ZYDOWN(NODE)).EQ.109 .OR.
     +          ZYNTYP(ZYDOWN(NODE)).EQ.87 .OR.
     +          ZYNTYP(ZYDOWN(NODE)).EQ.86) .AND.
     +          (ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.104 .OR.
     +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.108 .OR.
     +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.119 .OR.
     +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.109 .OR.
     +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.87 .OR.
     +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.86)) THEN
C Just a simple case of (A .AND/OR. B) - make it .NOT(A .AND/OR. B)
                TMP=ZYCRND(101,0)
                CALL ZYREPL(NODE,TMP)
                CALL ZYADSN(TMP,NODE)
                NODE=ZYCRND(88,0)
                CALL ZYREPL(TMP,NODE)
                CALL ZYADSN(NODE,TMP)
            ELSE
                IF (ZYNTYP(NODE).EQ.87) THEN
                    CALL ZYCHNT(NODE,86)
                ELSE
                    CALL ZYCHNT(NODE,87)
                END IF
                SP=SP+2
                STACK(SP-1)=ZYDOWN(NODE)
                STACK(SP)=ZYNEXT(ZYDOWN(NODE))
                IF (ZYNTYP(NODE).EQ.87) THEN
C If we just increased the priority (by changing .OR. to .AND.)
C then we must parenthesise any subexpressions which have as their
C top node .AND. (which we will change to .OR.).
                    IF (ZYNTYP(STACK(SP-1)).EQ.87) THEN
                        TMP=ZYCRND(101,0)
                        CALL ZYREPL(STACK(SP-1),TMP)
                        CALL ZYADSN(TMP,STACK(SP-1))
                    END IF
                    IF (ZYNTYP(STACK(SP)).EQ.87) THEN
                        TMP=ZYCRND(101,0)
                        CALL ZYREPL(STACK(SP),TMP)
                        CALL ZYADSN(TMP,STACK(SP))
                    END IF
                END IF
            END IF
        ELSE IF (ZYNTYP(NODE).EQ.101) THEN
            NODE=ZYDOWN(NODE)
            GOTO 100
        ELSE
            IF (ZYNTYP(NODE).NE.104 .AND.
     +          ZYNTYP(NODE).NE.108 .AND.
     +          ZYNTYP(NODE).NE.119 .AND.
     +          ZYNTYP(NODE).NE.109)
     +          CALL REMARK(
     +'Internal Error: UNUSUAL CONDITION FOUND - CONTINUING')
            TMP=ZYCRND(88,0)
            CALL ZYREPL(NODE,TMP)
            CALL ZYADSN(TMP,NODE)
        END IF
        IF (SP.GT.0) THEN
            NODE=STACK(SP)
            SP=SP-1
            GOTO 100
        END IF
C
C Finished condition reversal -- but now reparse it to factor out .NOT.
C operators -- i.e. turn .NOT.(A).AND..NOT(B) into .NOT.(A.OR.B) and
C similarly with .OR.
C (The reason this gets produced above is that when reversing we want to
C  turn A.GT.B .OR. C.EQ.0 into A.LE.B .AND. C.NE.0
C                    instead of .NOT.(A.GT.B .OR. C.EQ.0)
C
        NODE=COND
 200    IF (ZYNTYP(NODE).EQ.87 .OR. ZYNTYP(NODE).EQ.86) THEN
            IF (ZYNTYP(ZYDOWN(NODE)).EQ.88 .AND.
     +          ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.88) THEN
                TMP=ZYDOWN(NODE)
                CALL ZYREPL(TMP,ZYDOWN(TMP))
                CALL ZYREPL(NODE,TMP)
                CALL ZYADSN(TMP,NODE)
                TMP=ZYNEXT(ZYDOWN(NODE))
                CALL ZYREPL(TMP,ZYDOWN(TMP))
                CALL ZYREPL(NODE,TMP)
                CALL ZYADSN(TMP,NODE)
                CALL ZYCHNT(TMP,101)
                IF (ZYNTYP(NODE).EQ.87) THEN
                    CALL ZYCHNT(NODE,86)
                ELSE
                    CALL ZYCHNT(NODE,87)
C Once again, changing .OR. to .AND. may change meaning...
                    IF (ZYDOWN(NODE).EQ.86) THEN
                        TMP=ZYCRND(101,0)
                        CALL ZYREPL(ZYDOWN(NODE),TMP)
                        CALL ZYADSN(TMP,ZYDOWN(NODE))
                    END IF
                    IF (ZYNEXT(ZYDOWN(NODE)).EQ.86) THEN
                        TMP=ZYCRND(101,0)
                        CALL ZYREPL(ZYNEXT(ZYDOWN(NODE)),TMP)
                        CALL ZYADSN(TMP,ZYNEXT(ZYDOWN(NODE)))
                    END IF
                END IF
            ELSE
                IF (ZYNTYP(ZYDOWN(NODE)).EQ.87 .OR.
     +              ZYNTYP(ZYDOWN(NODE)).EQ.86) THEN
                    SP=SP+1
                    STACK(SP)=ZYDOWN(NODE)
                END IF
                IF (ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.87 .OR.
     +              ZYNTYP(ZYNEXT(ZYDOWN(NODE))).EQ.86) THEN
                    SP=SP+1
                    STACK(SP)=ZYNEXT(ZYDOWN(NODE))
                END IF
            END IF
        END IF
        IF (SP.GT.0) THEN
            NODE=STACK(SP)
            SP=SP-1
            GOTO 200
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       R E A C H   -   Calculate REACH set for IF node
C
 
        SUBROUTINE REACH(FG,FGSIZE,NODE,NEXTN,STACK,STKSIZ,SP,MAXSP)
        INTEGER FGSIZE,NODE,NEXTN,STKSIZ,SP,MAXSP
        INTEGER FG(8,FGSIZE),STACK(3,STKSIZ)
 
        INTEGER RSTKSZ
        PARAMETER (RSTKSZ=26)
 
        INTEGER REACHN,RSTACK(RSTKSZ),RSP,PTR,NUMBER,I
 
C RSTACK(nn) = "IF" node we are currently following true branch of
 
        LOGICAL NESTED
 
        EXTERNAL ERROR
 
        REACHN=0
        RSP=0
        PTR=NODE
 
 100    CONTINUE
C Here to process a nested node
        FG(7,PTR)=-FG(7,PTR)
        NUMBER=FG(4,PTR)
C Remember the numbering of it so we can detect backward refs
        IF (FG(2,PTR).LE.0) THEN
C Give up if it is an END or case
            GOTO 666
        ELSE IF (FG(3,PTR).GT.0) THEN
C An IF node -- push false branch (for later processing),
C then visit true branch; give up if too deeply nested.
            IF (RSP.EQ.RSTKSZ) GOTO 666
            RSP=RSP+1
            RSTACK(RSP)=PTR
            PTR=FG(2,PTR)
C If first node on "true" branch has only one inarc, we know it must
C be nested (if this is the forward inarc that is)
            IF (FG(7,PTR).EQ.1 .AND.
     +          NUMBER.LT.FG(4,PTR)) GOTO 100
        ELSE IF (FG(1,PTR).EQ.-1) THEN
C Repeat node - so first node of repeat is always properly nested
            PTR=FG(2,PTR)
            GOTO 100
        ELSE
C SLC node - visit next in sequence
C next node is always properly nested if it is in the follow set
            IF (FG(8,FG(2,PTR)).EQ.PTR) THEN
                PTR=FG(2,PTR)
                GOTO 100
            END IF
            PTR=FG(2,PTR)
        END IF
 
 200    CONTINUE
C Here to visit a node which may or may not be properly nested
C (but not if we have already done so)
        IF (FG(7,PTR).GE.0) THEN
            IF (NESTED(FG,FGSIZE,PTR,NODE)) THEN
C Yes it is - process it as such (unless it is a backward reference)
                IF (FG(4,PTR).GT.NUMBER) GOTO 100
            ELSE IF (REACHN.EQ.0) THEN
C No it isn't nested -- and the REACH set is empty, so remember it
                REACHN=PTR
            ELSE IF (REACHN.NE.PTR) THEN
C Non-singleton REACH set, so return now
                GOTO 666
            END IF
        END IF
 
C Finished processing current branch -- try next one
        IF (RSP.GT.0) THEN
            PTR=FG(3,RSTACK(RSP))
            NUMBER=FG(4,RSTACK(RSP))
            RSP=RSP-1
C Make sure node is nested though...
            GOTO 200
        END IF
 
C Finished REACH set calculation -- is it empty?
        IF (REACHN.EQ.0) THEN
            CALL ERROR('EMPTY REACH SET')
        ELSE IF (REACHN.NE.NEXTN) THEN
            CALL GFPUSH(STACK,STKSIZ,SP,REACHN,6,0,MAXSP)
        END IF
 
 666    DO 300 I=1,FGSIZE
            IF (FG(7,I).LT.0) FG(7,I)=-FG(7,I)
 300    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       N E S T E D   -   Is a node nested within another?
C
C       (Is ANODE nested within BNODE)
C
 
        LOGICAL FUNCTION NESTED(FG,FGSIZE,ANODE,BNODE)
        INTEGER FGSIZE,ANODE,BNODE
        INTEGER FG(8,FGSIZE)
 
        INTEGER DOMPTR
 
C ANODE is nested within BNODE if and only if
C    (1) DOM**N(ANODE)=BNODE for some N, and
C    (2) ANODE,DOM**N(ANODE) not in FOLLOW(BNODE)
 
        IF (FG(8,ANODE).EQ.BNODE) THEN
            NESTED=.FALSE.
        ELSE
            DOMPTR=FG(6,ANODE)
 100        IF (DOMPTR.NE.0 .AND. DOMPTR.NE.BNODE) THEN
                IF (FG(8,DOMPTR).NE.BNODE) THEN
                    DOMPTR=FG(6,DOMPTR)
                    GOTO 100
                END IF
            END IF
            NESTED=DOMPTR.EQ.BNODE
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       O U T F M T   -   Output the FORMAT statements
C
 
        SUBROUTINE OUTFMT(PUPTR,IODCMT,DESCO)
        INTEGER PUPTR,IODCMT,DESCO
 
        INTEGER PTR
 
        INTEGER ZYDOWN,ZYNEXT,ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZYNTYP,YSTMT
 
        PTR=ZYDOWN(PUPTR)
 
 100    IF (ZYNTYP(PTR).EQ.78) THEN
            CALL COMMNT(PTR,IODCMT,DESCO)
            CALL YSTMT(PTR,DESCO)
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       C K D E A D   -   Check a flowgraph for dead code
C
 
        SUBROUTINE CKDEAD(FG,FGSIZE,PUROOT,IODCMT,DESCO)
        INTEGER FGSIZE,STARTN,PUROOT,IODCMT,DESCO
        INTEGER FG(8,FGSIZE)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER I,SYMBOL(8),TEXT(134),WARNCM(31)
        LOGICAL CMWRND
 
        SAVE WARNCM
 
        INTEGER ZYGTXF,ZYPUSY,ZYNTYP,ZYNEXT
        EXTERNAL ZYGTXF,ZYPUSY,ZYNTYP,ZYNEXT,ZCHOUT,ZPTINT,ZYGTSY,
     +           ZYGTST,PUTLIN,ZMESS,ZUSCAN,PUTCH
 
C "*$st$ Unreachable comments ..."
 
        DATA WARNCM/42,36,115,116,36,32,85,110,114,
     +              101,97,99,104,97,98,108,101,32,99,
     +              111,109,109,101,110,116,115,32,46,
     +              46,46,129/
 
        CMWRND=.FALSE.
        DO 100 I=1,FGSIZE
            IF (FG(4,I).EQ.0) THEN
                IF (ZYNTYP(FG(1,I)).EQ.131) THEN
                    IF (.NOT.CMWRND) THEN
                        CALL ZUSCAN(TCMMNT,30,WARNCM,DESCO)
                        CALL ZCHOUT(
     +'Unreachable comments placed before END statement in ',2)
                        CALL ZYGTSY(ZYPUSY(PUROOT),SYMBOL)
                        CALL ZYGTST(SYMBOL(2),TEXT)
                        CALL PUTLIN(TEXT,2)
                        CALL PUTCH(10,2)
                    END IF
                    CMWRND=.TRUE.
                    CALL COMMNT(FG(1,I),IODCMT,DESCO)
                ELSE
                    CALL ZCHOUT('Unreachable statement ',2)
                    CALL ZPTINT(ZYGTXF(FG(1,I)),1,2)
                    CALL ZCHOUT(' in ',2)
                    CALL ZYGTSY(ZYPUSY(PUROOT),SYMBOL)
                    CALL ZYGTST(SYMBOL(2),TEXT)
                    CALL PUTLIN(TEXT,2)
                    CALL ZMESS(' eliminated..',2)
                END IF
            END IF
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       F L A T T N   -   Flatten (output) a program-unit, unchanged
C
 
        SUBROUTINE FLATTN(PUROOT,IODCMT,DESCO)
        INTEGER PUROOT,IODCMT,DESCO
 
        INTEGER PTR
 
        INTEGER ZYDOWN,ZYNEXT
        EXTERNAL ZYDOWN,ZYNEXT,YSTMT
 
        PTR=ZYDOWN(PUROOT)
 100    CALL COMMNT(PTR,IODCMT,DESCO)
        CALL YSTMT(PTR,DESCO)
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       C O M M N T   -   Output comments associated with a statement
C
 
        SUBROUTINE COMMNT(NODE,IODCMT,DESCO)
        INTEGER NODE,IODCMT,DESCO
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER TEXT(134),STMTNO
 
        INTEGER ZYGTCM,ZYGNCM,ZYGTXF,LENGTH
        EXTERNAL ZYGTCM,ZYGNCM,ZYGTXF,LENGTH,ZUSCAN
 
        STMTNO=ZYGTXF(NODE)
        IF (STMTNO.NE.0) THEN
            IF (ZYGTCM(IODCMT,STMTNO,TEXT).NE.-100) THEN
 100            CALL ZUSCAN(TCMMNT,LENGTH(TEXT),TEXT,DESCO)
                IF (ZYGNCM(IODCMT,TEXT).NE.-100) GOTO 100
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       E R R O U T   -   Produce error/warning message
C
 
        SUBROUTINE ERROUT(STRING,STPTR)
        CHARACTER*(*) STRING
        INTEGER STPTR
 
        INTEGER TEXT(1322),SYMBOL(8)
 
        INTEGER ZYGTXF,ZYDOWN,ZYUP,ZYPUSY
        EXTERNAL ZYGTXF,ZYDOWN,ZYUP,ZYPUSY,ZCHOUT,ZPTINT,ZYGTSY,ZYGTST,
     +           PUTLIN,PUTCH
 
        CALL ZCHOUT(STRING,2)
        CALL ZCHOUT(' at statement ',2)
        CALL ZPTINT(ZYGTXF(STPTR)-ZYGTXF(ZYDOWN(ZYUP(STPTR)))+1,1,
     +              2)
        CALL ZCHOUT(' in ',2)
        CALL ZYGTSY(ZYPUSY(ZYUP(STPTR)),SYMBOL)
        CALL ZYGTST(SYMBOL(2),TEXT)
        CALL PUTLIN(TEXT,2)
        CALL PUTCH(10,2)
 
        END
